home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / structure < prev    next >
Text File  |  1993-03-25  |  3KB  |  66 lines
  1. ;;; This file was munged by a simple minded sed script since it left
  2. ;;; its original authors' hands.  See syncase.doc for the horrid details.
  3.  
  4. ;;; structure.ss
  5. ;;; Robert Hieb & Kent Dybvig
  6. ;;; 92/06/18
  7.  
  8. (define-syntax define-structure
  9.    (lambda (x)
  10.       (define construct-name
  11.          (lambda (template-identifier . args)
  12.             (implicit-identifier
  13.                template-identifier
  14.                (string->symbol
  15.                   (apply string-append
  16.                          (map (lambda (x)
  17.                                  (if (string? x)
  18.                                      x
  19.                                      (symbol->string (syntax-object->datum x))))
  20.                               args))))))
  21.       (syntax-case x ()
  22.          ((_ (name id1 ...))
  23.           (syntax (define-structure (name id1 ...) ())))
  24.          ((_ (name id1 ...) ((id2 init) ...))
  25.           (with-syntax
  26.              ((constructor (construct-name (syntax name) "make-" (syntax name)))
  27.               (predicate (construct-name (syntax name) (syntax name) "?"))
  28.               ((access ...)
  29.                (map (lambda (x) (construct-name x (syntax name) "-" x))
  30.                     (syntax (id1 ... id2 ...))))
  31.               ((assign ...)
  32.                (map (lambda (x)
  33.                        (construct-name x "set-" (syntax name) "-" x "!"))
  34.                     (syntax (id1 ... id2 ...))))
  35.               (structure-length
  36.                (+ (length (syntax (id1 ... id2 ...))) 1))
  37.               ((index ...)
  38.                (let f ((i 1) (ids (syntax (id1 ... id2 ...))))
  39.                   (if (null? ids)
  40.                       '()
  41.                       (cons i (f (+ i 1) (cdr ids)))))))
  42.              (syntax (begin
  43.                         (define constructor
  44.                            (lambda (id1 ...)
  45.                               (let* ((id2 init) ...)
  46.                                  (vector 'name id1 ... id2 ...))))
  47.                         (define predicate
  48.                            (lambda (x)
  49.                               (and (vector? x)
  50.                                    (= (vector-length x) structure-length)
  51.                                    (eq? (vector-ref x 0) 'name))))
  52.                         (define access
  53.                            (lambda (x)
  54.                               (vector-ref x index)))
  55.                         ...
  56.                         ; define macro accessors this way:
  57.                         ; (define-syntax access
  58.                         ;       (syntax-case x ()
  59.                         ;          ((_ x)
  60.                         ;           (syntax (vector-ref x index))))))
  61.                         ; ...
  62.                         (define assign
  63.                            (lambda (x update)
  64.                               (vector-set! x index update)))
  65.                         ...)))))))
  66.